SPACE 2

home *** CD-ROM | disk | FTP | other *** search

/ SPACE 2 / SPACE - Library 2 - Volume 1.iso / program / 18 / forthsup / linea.fth < prev next >

Wrap

Text File | 1986-09-18 | 5.7 KB | 216 lines

\ "Line A" Graphics Interface \ Written by Jesse Taylor. decimal variable a-vars \ Create a name which will return the address stored in a-vars plus an offset : afield: ( offset -- ) create , \ does> @ a-vars @ + ;code sp )+ a0 lmove a0 ) a0 lmove a-vars l#) a0 adda a0 sp -) lmove c; \ These fields reflect the offsets into the table pointed to by A0 when the \ line A graphics are first initialized. 0 afield: v_planes 2 afield: v_lin_wr 4 afield: contrl 8 afield: intin 12 afield: ptsin 16 afield: intout 20 afield: ptsout 24 afield: _fg_bp_1 26 afield: _fg_bp_2 28 afield: _fg_bp_3 30 afield: _fg_bp_4 32 afield: _lstlin 34 afield: _ln_mask 36 afield: _wrt_mod 38 afield: _x1 40 afield: _y1 42 afield: _x2 44 afield: _y2 46 afield: _patptr 50 afield: _patmsk 52 afield: _multifill 54 afield: _clip 56 afield: _xmn_clip 58 afield: _ymn_clip 60 afield: _xmx_clip 62 afield: _ymx_clip 64 afield: _xacc_dda 66 afield: _dda_inc 68 afield: _t_sclsts 70 afield: _mono_status 72 afield: _sourcex 74 afield: _sourcey 76 afield: _destx 78 afield: _desty 80 afield: _delx 82 afield: _dely 84 afield: _fbase 86 afield: _fwidth 90 afield: _style 92 afield: _litemask 94 afield: _skewmask 96 afield: _weight 98 afield: _r_off 100 afield: _l_off 102 afield: _scale 104 afield: _chup 106 afield: _text_fg 108 afield: _scrtchchp 112 afield: _scrpt2 114 afield: _text_bg 116 afield: _copytran -324 afield: mouse-clipped? \ th 200 bit is off if clipped to the right -326 afield: mouse-raster \ mouse offset from beginning of screen mem. \ plus th 8000 -330 afield: mouse-cursor-height \ Height in pixels of the mouse cursor -340 afield: mouse-moved? \ Toggles if mouse moves more than threshhold -342 afield: mouse-y \ mouse y in pixel coordinates -344 afield: mouse-x \ mouse x in pixel coordinates -348 afield: mouse-buttons \ mouse button flags \ 8000 - last button was the right one \ 4000 - last button was the left one \ 0200 - right button is down \ 0100 - left button is down \ these are the regular program variables variable patmskv 7 patmskv ! hex decimal \ this is a table containing the three resolution modes on the st create rez-table 320 w, 200 w, 640 w, 200 w, 640 w, 400 w, hex : get-rez ( -- x y ) \ return current screen resolution getrez 4 * rez-table + dup w@ swap 2+ w@ ; code init-a ( -- addr ) \ line A graphics init routine a000 w, a0 a-vars l#) lmove c; code put-pix ( -- ) a001 w, c; \ set pixel code get-pix ( -- n ) a002 w, d0 sp -) lmove c; \ get pixel code do-line ( -- ) a003 w, c; \ draw line code h-line ( -- ) a004 w, c; \ horizontal line code fill-rec ( -- ) a005 w, c; \ filled rectangle code fill-poly ( -- ) a006 w, c; \ filled polygon code show-mouse ( -- ) a007 w, c; \ show mouse code hide-mouse ( -- ) a00a w, c; \ hide mouse code transform-mouse ( -- ) a00b w, c; \ transform mouse cursor code copy-raster ( -- ) a00e w, c; \ raster copy \ Draw sprite (a00d) and undraw sprite (a00c) are missing decimal : set-clip ( x1 y1 x2 y2 -- ) \ set the clipping rectangle _ymx_clip w! _xmx_clip w! _ymn_clip w! _xmn_clip w! ; : color ( pl1 pl2 pl3 pl4 -- ) \ set the 4 color planes _fg_bp_4 w! _fg_bp_3 w! _fg_bp_2 w! _fg_bp_1 w! ; : lmask! ( n -- ) \ set the line mask variable _ln_mask w! ; : line-a-init ( -- ) \ high level line a initialization routine init-a -1 lmask! -1 _lstlin w! 0 _multifill w! 1 0 0 0 color patmskv @ _patmsk w! 0 0 640 400 set-clip ; : !pix ( x y value -- ) \ high level pixel setting routine intin @ w! ptsin @ swap over 2+ w! w! put-pix ; : @pix ( x y -- value ) \ high level pixel fetching ptsin @ swap over 2+ w! w! get-pix ; : draw ( x1 y1 x2 y2 -- ) \ high level line routine _y2 w! _x2 w! _y1 w! _x1 w! do-line ; : rectangle ( x1 y1 x2 y2 -- ) \ draw a filled rectangle _y2 w! _x2 w! _y1 w! _x1 w! fill-rec ; decimal : poly-line ( addr n -- ) \ draw a line polygon 4* over + swap do i w@ i 2+ w@ i 4 + w@ i 6 + w@ draw 4 +loop ; code polygon ( y1 y2 addr n -- ) \ fast polygon inner loop sp )+ d0 lmove a-vars l#) a1 lmove ' contrl >body @ a1 d) a2 lmove d0 2 a2 d) wmove ' ptsin >body @ a1 d) d7 lmove sp )+ ' ptsin >body @ a1 d) lmove sp )+ d6 lmove sp )+ d5 lmove a3 sp -) lmove \ Save a3 a1 a3 lmove \ a1 gets clobbered so we use a3 d5 d6 sub begin d5 ' _y1 >body @ a3 d) wmove hex a006 w, decimal 1 d5 addq d6 dbra d7 ' ptsin >body @ a3 d) lmove sp )+ a3 lmove c; \ this is an example of the use of the polygon routine \ create poly1 \ 100 w, 100 w, 100 w, 200 w, \ 1 w, 300 w, 600 w, 250 w, \ 200 w, 375 w, 100 w, 100 w, \ : polytest \ poly1 5 poly-line \ ; 2 xbios: physbase { -- a.screen-base } physbase constant scradr decimal create mfdb scradr , \ I'm not sure the next line is right getrez dup 4* rez-table + dup w@ swap @ , 16 / w, 0 w, 2* 1 max 4 swap - 1 max w, 0 w, 0 , \ rasmove (raster copy) is a fast low level bit map move routine decimal : rasmove ( sx1 sy1 sx1 sx2 dx1 dy1 dx2 dy2 m -- ) mfdb dup contrl @ 14 + 2! intin @ w! ptsin @ dup 14 + do i w! -2 +loop copy-raster ;